{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}

module FRP.Taupo.Sync (SyncSignal, signal, event, output) where

import Control.Applicative (liftA2)
import Control.Selective (Selective (select))
import Data.Bifunctor (second)
import Data.Functor (void)
import Data.Functor.Apply (Apply ((<.>)))
import Data.Functor.Combinator (HFunctor (hmap), Inject (inject), Interpret (interpret, retract))
import Data.Kind (Type)
import Data.Semialign (Repeat (repeat), Semialign (align, alignWith), Zip (zip, zipWith))
import Data.These (These (These))
import Prelude hiding (repeat, zipWith)

data SyncSignal (eff :: Type -> Type) (a :: Type) where
  SyncSignal :: eff a -> SyncSignal eff a
  SyncEvent :: eff b -> SyncSignal eff a -> SyncSignal eff a
  SyncMux :: (a -> b -> c) -> SyncSignal eff a -> SyncSignal eff b -> SyncSignal eff c
  SyncSelect :: SyncSignal eff (Either a b) -> SyncSignal eff (a -> b) -> SyncSignal eff b

instance (Functor eff) => Functor (SyncSignal eff) where
  fmap f = \case
    SyncSignal act -> SyncSignal (fmap f act)
    SyncEvent g sig -> SyncEvent g (fmap f sig)
    SyncMux g sig1 sig2 -> SyncMux (\x -> f . g x) sig1 sig2
    SyncSelect sigDat sigCtrl -> SyncSelect (fmap (second f) sigDat) (fmap (f .) sigCtrl)
  (<$) x = \case
    SyncSignal act -> SyncSignal (x <$ act)
    SyncEvent g sig -> SyncEvent g (x <$ sig)
    SyncMux _ sig1 sig2 -> SyncMux (\_ _ -> x) sig1 sig2
    SyncSelect sigDat sigCtrl -> SyncSelect (Right x <$ sigDat) (const x <$ sigCtrl)

instance (Functor eff) => Semialign (SyncSignal eff) where
  align = SyncMux These
  alignWith f = SyncMux (\x -> f . These x)

instance (Apply eff) => Zip (SyncSignal eff) where
  zip sig1 sig2 = case sig1 of
    SyncSignal act -> case sig2 of
      SyncSignal act' -> SyncSignal ((,) <$> act <.> act')
      _ -> SyncMux (,) sig1 sig2
    _ -> SyncMux (,) sig1 sig2
  zipWith f sig1 sig2 = case sig1 of
    SyncSignal act -> case sig2 of
      SyncSignal act' -> SyncSignal (f <$> act <.> act')
      _ -> SyncMux f sig1 sig2
    _ -> SyncMux f sig1 sig2

-- Redundant, but needed as we can't back-infer Apply from Applicative, sigh.
instance (Apply eff, Applicative eff) => Repeat (SyncSignal eff) where
  repeat x = SyncSignal (pure x)

instance (Apply eff, Applicative eff) => Applicative (SyncSignal eff) where
  pure = repeat
  liftA2 = zipWith
  (<*>) = zipWith ($)

instance (Apply eff, Selective eff) => Selective (SyncSignal eff) where
  select sigDat sigCtrl = case sigDat of
    SyncSignal act -> case sigCtrl of
      SyncSignal act' -> SyncSignal (select act act')
      _ -> SyncSelect sigDat sigCtrl
    _ -> SyncSelect sigDat sigCtrl

instance HFunctor SyncSignal where
  hmap nt = \case
    SyncSignal act -> SyncSignal (nt act)
    SyncEvent g sig -> SyncEvent (nt g) (hmap nt sig)
    SyncMux g sig1 sig2 -> SyncMux g (hmap nt sig1) (hmap nt sig2)
    SyncSelect sigDat sigCtrl -> SyncSelect (hmap nt sigDat) (hmap nt sigCtrl)

instance Inject SyncSignal where
  inject = SyncSignal

instance (Selective eff) => Interpret SyncSignal eff where
  retract = \case
    SyncSignal act -> act
    SyncEvent f sig -> retract sig <* f
    SyncMux g sig1 sig2 -> g <$> retract sig1 <*> retract sig2
    SyncSelect sigDat sigCtrl -> select (retract sigDat) . retract $ sigCtrl
  interpret nt = \case
    SyncSignal act -> nt act
    SyncEvent f sig -> interpret nt sig <* nt f
    SyncMux g sig1 sig2 -> g <$> interpret nt sig1 <*> interpret nt sig2
    SyncSelect sigDat sigCtrl -> select (interpret nt sigDat) . interpret nt $ sigCtrl

signal :: eff a -> SyncSignal eff a
signal = SyncSignal

event :: eff () -> SyncSignal eff a -> SyncSignal eff a
event = SyncEvent

output :: (Functor eff) => SyncSignal eff a -> SyncSignal eff ()
output = void
